home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / compile.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  9KB  |  255 lines
  1. ;;;; compile.jl -- Running compilation processes
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'compile)
  21.  
  22. (setq gcc-error-regexp "^(.*):([0-9]+):(.+)"
  23.       gcc-file-expand "\\1"
  24.       gcc-line-expand "\\2"
  25.       gcc-error-expand "\\3")
  26.  
  27. (defvar compile-error-regexp gcc-error-regexp
  28.   "String used to match error messages in compilation output.")
  29. (defvar compile-file-expand gcc-file-expand
  30.   "Expansion template for the name of the file in an error matched by
  31. `compile-error-regexp'.")
  32. (defvar compile-line-expand gcc-line-expand
  33.     "Expansion template for the line number of an error matched by
  34. `compile-error-regexp'.")
  35. (defvar compile-error-expand gcc-error-expand
  36.     "Expansion template for the error description in an error matched by
  37. `compile-error-regexp'.")
  38.  
  39. (defvar compile-keymap (make-keylist))
  40.  
  41. (unless (boundp 'compile-buffer)
  42.   (bind-keys compile-keymap
  43.     "Ctrl-c" 'kill-compilation
  44.     "Ctrl-z" 'stop-compilation
  45.     "Ctrl-f" 'continue-compilation
  46.     "r" '(start-compile-command compile-default-cmd compile-type-str)
  47.     "Ctrl-r" 'compile))
  48.  
  49. (defvar compile-buffer nil)
  50. (defvar compile-proc nil)
  51. (defvar compile-errors nil "List of (ERROR-POS-MARK . ERROR-DESC-LINE)")
  52. (defvar compile-error-pos nil)
  53. (defvar compile-type-str nil)
  54. (defvar compile-error-parsed-errors-p nil)
  55. (defvar compile-errors-exist-p nil)
  56.  
  57. (defvar compile-default-cmd "make"
  58.   "Default command which `(compile)' executes, the value of the last
  59. command executed by `(compile)'.")
  60.  
  61. (defvar compile-command nil
  62.   "Buffer-local symbol which contains the command to compile this buffer. If
  63. nil or unbound use `compile-default-cmd'.")
  64. (make-variable-buffer-local 'compile-command)
  65.  
  66. (defvar compile-shell (unless (getenv "SHELL") "/bin/sh")
  67.   "The filename of the shell to use to run the compilation in.")
  68.  
  69. (defun compile-init ()
  70.   (if compile-buffer
  71.       (clear-buffer compile-buffer)
  72.     (setq compile-buffer (make-buffer "*compilation*"))
  73.     (with-buffer compile-buffer
  74.       (setq ctrl-c-keymap compile-keymap))
  75.     (set-buffer-special compile-buffer t))
  76.   (when compile-buffer
  77.     (add-buffer compile-buffer)
  78.     (set-buffer-file-name compile-buffer (file-name-directory (buffer-file-name)))
  79.     (setq compile-errors nil
  80.       compile-parsed-errors-p nil
  81.       compile-errors-exists-p nil
  82.       compile-error-pos (buffer-start))
  83.     t))
  84.  
  85. (defun compile-callback ()
  86.   (when compile-proc
  87.     (cond
  88.      ((process-stopped-p compile-proc)
  89.       (write (cons compile-buffer t) "Compilation suspended..."))
  90.      ((process-running-p compile-proc)
  91.       (write (cons compile-buffer t) "restarted\n"))
  92.      (t
  93.       (beep)
  94.       (if (process-exit-value compile-proc)
  95.       (format (cons compile-buffer t) "\n%s%d\n"
  96.           "Compilation exited with value "
  97.           (process-exit-value compile-proc))
  98.     (format (cons compile-buffer t) "\n%s%x\n"
  99.         "Compilation exited abnormally: status 0x"
  100.         (process-exit-status compile-proc)))
  101.       (setq compile-proc nil)))))
  102.  
  103. ;;;###autoload
  104. (defun start-compile-command (command type-str)
  105.   "<UNIX-ONLY>
  106. Executes SHELL-COMMAND asynchronously in the directory containing the file
  107. being edited in the current buffer. Output from the process is sent to the
  108. `*compilation*' buffer. TYPE-STR is a string describing the type of messages
  109. the command may output (i.e. `errors' for a compilation)."
  110.   (if compile-proc
  111.       (error "Compilation process already running")
  112.     (save-some-buffers)
  113.     (compile-init)
  114.     (goto-buffer compile-buffer)
  115.     (setq compile-proc (make-process (cons compile-buffer t)
  116.                      'compile-callback
  117.                      (file-name-directory (buffer-file-name))))
  118.     (let
  119.     ((shell-cmd (concat command ?\n)))
  120.       (write compile-buffer shell-cmd)
  121.       (when (start-process compile-proc compile-shell "-c" shell-cmd)
  122.     (setq compile-type-str type-str)
  123.     compile-proc))))
  124.  
  125. (defun kill-compilation ()
  126.   (interactive)
  127.   (when compile-proc
  128.     (interrupt-process compile-proc t)))
  129.  
  130. (defun stop-compilation ()
  131.   (interactive)
  132.   (when (process-running-p compile-proc)
  133.     (stop-process compile-proc t)))
  134.  
  135. (defun continue-compilation ()
  136.   (interactive)
  137.   (when (process-stopped-p compile-proc)
  138.     (continue-process compile-proc t)))
  139.  
  140. ;;;###autoload
  141. (defun compile (&optional shell-command)
  142.   "<UNIX-ONLY>
  143. Runs the SHELL-COMMAND in the `*compilation*' buffer. If SHELL-COMMAND isn't
  144. given you will be prompted for a command."
  145.   (interactive)
  146.   (unless shell-command
  147.     (setq shell-command (or compile-command
  148.                 (setq
  149.                  compile-default-cmd
  150.                  (prompt "Compile command: "
  151.                      compile-default-cmd)))))
  152.   (when shell-command
  153.     (start-compile-command shell-command "errors")))
  154.  
  155. (defun compile-parse-errors ()
  156.   ;; This can be called while the process is still running, one problem though,
  157.   ;; if the compiled file is modified and then a new error is found the line
  158.   ;; numbers won't coincide like they normally would.
  159.   (unless compile-parsed-errors-p
  160.     (with-buffer compile-buffer
  161.       (let*
  162.       (error-file
  163.        error-line
  164.        last-e-line
  165.        last-e-file
  166.        new-errors)
  167.     (while (setq compile-error-pos (find-next-regexp compile-error-regexp
  168.                              compile-error-pos))
  169.       (setq error-line (1- (read-from-string (regexp-expand-line
  170.                           compile-error-regexp
  171.                           compile-line-expand
  172.                           compile-error-pos))))
  173.       (when (or (not last-e-line) (/= error-line last-e-line))
  174.         (setq last-e-line error-line
  175.           error-file (file-name-concat (buffer-file-name)
  176.                            (regexp-expand-line
  177.                         compile-error-regexp
  178.                         compile-file-expand
  179.                         compile-error-pos)))
  180.         (if (equal last-e-file error-file)
  181.         (setq error-file last-e-file)
  182.           (setq last-e-file error-file))
  183.         (setq new-errors (cons (cons (make-mark (pos 0 error-line)
  184.                             error-file)
  185.                      (pos-line compile-error-pos))
  186.                    new-errors)))
  187.       (setq compile-error-pos (match-end)))
  188.     (when new-errors
  189.       (setq compile-errors (nconc compile-errors (nreverse new-errors))
  190.         compile-errors-exist-p t))))
  191.     (unless compile-proc
  192.       (setq compile-parsed-errors-p t)))
  193.   t)
  194.  
  195. ;;;###autoload
  196. (defun next-error ()
  197.   "Moves the cursor to the file and line of the next error displayed in the
  198. `*compilation*' buffer."
  199.   (interactive)
  200.   (compile-parse-errors)
  201.   (let*
  202.       ((err (car compile-errors)))
  203.     (setq compile-errors (cdr compile-errors))
  204.     (cond
  205.      ((not err)
  206.       (message (concat "No " (if compile-errors-exist-p "more ")
  207.                compile-type-str (if compile-proc " yet")))
  208.       (beep)
  209.       nil)
  210.      (t
  211.       (goto-mark (car err))
  212.       (when (cdr err)
  213.     (message (regexp-expand-line compile-error-regexp compile-error-expand
  214.                      (pos 0 (cdr err)) compile-buffer)))
  215.       t))))
  216.  
  217. ;;;###autoload
  218. (defun grep (args-string)
  219.   "<UNIX-ONLY>
  220. Runs the `grep' program with ARGS-STRING (or the result of a prompt) and
  221. sends its output to the `*compilation*' buffer. The `grep' process may still
  222. be executing when this function returns."
  223.   (interactive "sGrep with args:")
  224.   (when args-string
  225.     (start-compile-command (concat "grep -n "
  226.                    args-string 
  227.                    " /dev/null /dev/null")
  228.                "grep-hits")))
  229.  
  230. (defvar grep-buffer-regexp nil
  231.   "Regular-expression which `grep-buffer' scans for")
  232.  
  233. ;;;###autoload
  234. (defun grep-buffer (&optional regexp)
  235.   "Scans the current buffer for all matches of REGEXP (or the contents of
  236. variable `grep-buffer-regexp'). All hits are displayed in the `*compilation*'
  237. buffer in a form that `goto-next-error' understands."
  238.   (interactive)
  239.   (when regexp
  240.     (setq grep-buffer-regexp regexp))
  241.   (when (and grep-buffer-regexp (compile-init))
  242.     (let*
  243.     ((scanpos (buffer-start))
  244.      (number 0)
  245.      (stream (cons compile-buffer t)))
  246.       (write stream ?\n)
  247.       (while (setq scanpos (find-next-regexp grep-buffer-regexp scanpos))
  248.     (format stream "%s:%d:%s\n" (buffer-file-name) (pos-line scanpos)
  249.         (copy-area (line-start scanpos) (line-end scanpos)))
  250.     (setq number (+ number 1)
  251.           scanpos (line-end scanpos)))
  252.       (goto-buffer compile-buffer)
  253.       (goto-buffer-start)
  254.       number)))
  255.